; this file is: Common.txt  --  forth words
; Tue Apr 05, 1988 21:59:10 load files >32K
; Thu Apr 07, 1988 15:59:46 nested loads
; Tue Apr 19, 1988 05:05:37 change "?button"
; Mon Apr 25, 1988 15:10:19 implement macros
; Tue Apr 26, 1988 19:49:49 optomizing "back"
; Thu Apr 28, 1988 23:09:23 fix id.  better constant,2constant  add zero
; Fri Apr 29, 1988 09:43:49 add dliteral
; Sun May 01, 1988 04:24:52 make variable a macro
; Thu May 12, 1988 11:41:08 remove (pdo)  add 1- 2- & sp@  use slashFail
; Sun May 29, 1988 20:16:39 make create shorter
; Tue May 31, 1988 14:27:25 make +md a 4 byte macro  remove 2-
; Tue Jun 07, 1988 11:39:00 add r0@, s0@, rp@  redo stod
; Sun Jun 23, 1991 09:33:00 add open
; Thu Jan 13, 1992 19:05:00 Floating point math (rewrite 13Apr)
; Sun Feb 02, 1992 00:02:00 fix back
; Wed Apr 01, 1992 00:12:00 change stkchk
; Tue Apr 14, 1992 22:48:00 rearrange to bring essentials toward front
; Sun Apr 19, 1992 23:24:00 split open into 2 parts, add: ae: ;ae> ?gestalt
; Sat Aug 08, 1992 18:53:00 remove ae: ;ae> bye  revert stkchk open  --> grow 
; Sat Jan 23, 1993 21:43:00 fix type and froll
; Fri May 28, 1993 22:50:00 move ?BUTTON and FLITERAL, fix +LOOP and QUIT

; ----- the dictionary ------

DictStart:
	DC.L	0			; End of dictionary search
	
	DC.B	128+1,13,0,0		; "{cr}" ( -- )
	DC.W	DictStart-base
CRet:	JSR	pasting-base(BP)	; interpret from the scrap
	TST.B	fint-base(BP)
	BEQ.S	@0
	MOVE.B	#0,0(IS,D5)		; replace CR with null
    @0:	JMP	Main
	
	DC.B	129,0,0,0		; "{null}" ( -- )
	DC.W	cret-theLink		; interpret from the keyboard
NRet:	JSR	clearTermBuf-base(BP)
	CLR.L	Counter			; clear input buffer offset
	TST.B	fcolon-base(BP)
	BNE.S	@0			; don't issue prompt if compiling
	JSR	prompt-base(BP)
    @0:	JMP	kdone-base(BP)		; jump back to the application

	DC.B	128+1,'\',0,0		; "\" ( -- ) backslash
	DC.W	nret-theLink		;  line ending comment
Backsl:	bra.s	cret

	DC.B	9,'?TE'			; "?terminal" ( -- flag )
	DC.W	backsl -theLink		;  was a key pressed?
qTerm:	JMP	qtcode-base(BP)

	DC.B	3,'KEY'			; "key" ( -- ascii )
	DC.W	qterm-theLink		;   wait for a key press
Key:	JMP	keycode-base(BP)

	DC.B	6,'?ST'			; "?stack" ( ? -- )
	DC.W	key-theLink
StkChk:	CMPA.L	UFlow-base(BP),PS
	BPL.S	@0
	RTS
    @0:	JSR	space-base(BP)
  	MOVEQ	#42,D0			; print *  if stack underflow
	JSR	EmitCode-base(BP)
	BRA.S	huh

	DC.B	7,'?BU'			; "?button" ( -- flag )
	DC.W	StkChk-theLink
QButton:
	CLR	-(SP)
	_Button
	MOVE	(SP)+,-(PS)
	BEQ.S	@0
	SUBI	#257,(PS)
    @0:	RTS

	DC.B    6,'WHA'			; "whazat" ( -- )
	DC.W	QButton-theLink
WhaZat:	JSR	dwrd-base(bp)
	BRA.S	huh
	
	DC.B	5,'ABO'			; "abort" ( -- )
	DC.W	whazat-theLink
huh:	MOVE.L	Szero-base(BP),PS
	MOVEQ	#63,D0			; send ?  means not found in dict
	JSR	EmitCode-base(BP)
	bsr.s	crlf
	BRA.S	fin
	
	DC.B	4,'QUI'			; "quit" ( -- )
	DC.W	huh-theLink		;    clear stacks and restart
fin:	JSR	emptyfs-base(BP)	; clear pending loads
	CLR.L	fcolon-base(BP)		; initialize flags
	BSET.B	#7,fint-base(BP)
	JMP	nret-base(BP)

	DC.B	2,'CR',0		; "cr" ( -- ) output CR to screen
	DC.W	fin-theLink
CRLF:	JMP	doCR-Base(BP)

	DC.B	3,'.OK'			; ".ok" ( -- )
	DC.W	crlf-theLink
Prompt:	JSR	space-base(BP)		; send space
	MOVEQ	#111,D0
	JSR	EmitCode-base(BP)	; send "o"
	MOVEQ	#107,D0
	JSR	EmitCode-base(BP)	; send "k"
	JMP	space-base(BP)		; send another space & return

	DC.B	5,'UPP'			; "upper" ( addr -- )
	DC.W	prompt-theLink		;   change a string to upper case
Upper:	MOVE	(PS)+,D0
	LEA	0(BP,D0.W),A0		; get the address
	CLR	D0
	MOVE.B	(A0),D0			; get count
    @0:	CMPI.B	#$60,0(A0,D0.W)		; BEGIN  get char at addr + count
	BLE.S	@1			;   char > 'a'
	CMPI.B	#$7B,0(A0,D0.W)		;   char < 'z'
	BGE.S	@1			;   AND IF
	SUBI.B	#32,0(A0,D0.W)		;     char 32 - -> char THEN
    @1:	DBRA	D0,@0			; count 1- -> count count NOT UNTIL
	RTS

	DC.B	5,'TOK'			; "token" ( -- ) put a token
	DC.W	upper-theLink		;   from (IS) into (DP),
Token:	MOVE	#32,-(PS)		;   which is at end of dict.
	BSR.S	word
	JSR	here-base(BP)		; Fri Apr 29, 1988 00:27:23 simpl
	BRA.S	Upper

	DC.B	6,'HEA'			; "header" ( -- ) create a header
	DC.W	token-theLink		;   for the current word at DP
Header:	MOVE	Dict,4(DP)		; link header to dictionary
	MOVE.L	DP,Dict			; update DICT
	SUB.L	BP,Dict			; make it a rel.addr
	addq.l	#6,dp			; update DP    ; (was) LEA 6(DP),DP
	RTS

	DC.B	4,'WOR'			; "word" ( c -- ) c is delimiter
	DC.W	header-theLink		;   get chars from (IS) into HERE
Word:	MOVE.L	D4,-(SP)		; preserve the register
	MOVE	(PS)+,D4		; get delimiter character
	CLR.L	(DP)			; clear token buffer
	CLR.L	D1			; clear count
    @0:	MOVE.B	(IS)+,D0		; get characters until delimiter
	CMP.B	D4,D0
	BEQ.S	@1
	MOVE.B	D0,1(DP,D1)		; place in token buffer
	ADDQ.B	#1,D1			; increment count
	BRA.S	@0
    @1:	MOVE.B	D1,(DP)			; put count in 1st byte of buffer
	BEQ.S	@0			; if count is 0 repeat
	MOVE.L	(SP)+,D4		; restore the register
	RTS

	DC.B	1,'''',0,0		; "'" ( -- rel.addr ) return the
	DC.W	word-theLink		;  cfa of the following word
Tick:	bsr.s	token			; get the next word
	MOVE	Dict,-(PS)		; push dict ptr to parmstk
	bsr.s	search			; lookup the current token
	TST	(PS)+
	BEQ	Whazat
	RTS

	DC.B	6,'SEA'			; "search" ( addr -- cfa t  OR  f )
	DC.W	tick-theLink
Search:	MOVE.L	(DP),D1			; put token "stem" in D1
	MOVE	(PS),D0			; use A0 as search pointer
	CLR	fmacro-base(BP)		; clear the macro flag
    @0:	LEA	0(BP,D0.W),A0		; DO
	TST	(A0)			;   IF DictStart  exit NOFIND
	BEQ.S	nofind
	CMP.L	(A0),D1			;   compare word to candidate
	BEQ.S	find			;   IF found, exit FIND
	BCHG	#31,D1			;   set immediate bit
	CMP.L	(A0),D1			;   compare to "immediate" version
	BEQ.S	ifind			;   IF found, exit FINDIMM
	BCHG	#31,D1			;   reset immediate bit
	BCHG	#30,D1			;   set macro bit
	CMP.L	(A0),D1			;   compare to "immediate" version
	BEQ.S	mfind			;   IF found, exit FINDIMM
	BCHG	#30,D1			;   reset macro bit
	MOVE	4(A0),D0		;   get link rel.address
	BRA.S	@0			; LOOP
nofind:	CLR	(PS)			; push fail flag
	RTS
 mfind:	BSET.B	#7,fmacro-base(BP)	; set macro flag
	BRA.S	find
 ifind:	BSET.B	#7,fimmed-base(BP)	; set immediate flag
  find:	LEA	6(A0),A0		; cfa is at 6+nfa
	SUBA.L	BP,A0			; convert code address to relative
	MOVE	A0,(PS)			; push code rel address
	MOVE	#-1,-(PS)		; push success flag
	RTS

	DC.B	6,'NUM'			; "number" ( addr -- n t  OR  f )
	DC.W	search-theLink
Number:	MOVE.L	D4,-(SP)		; save the register
	CLR.L	D1
	CLR.L	D4			; clear conversion register
	MOVE	(PS)+,D0		; get token addr in D0
	LEA	0(BP,D0.W),A0		; put abs.addr in A0
	CMPI.B	#'-',1(A0)		; is it negative?
	BNE.S	@0			; IF yes
	BSET.B	#7,fneg-base(BP)	;     set negative flag
	MOVE.B	#'0',1(A0)		;     change dash to zero
    @0:	CLR.L	D0			; THEN
	MOVE.B	(A0)+,D1		; get digit count
 digit:	MOVE.B	(A0)+,D0		; BEGIN get next digit
	SUBI.B	#48,D0			;     strip ASCII prefix
	BLT.S	@2			;     if digit too small, FAIL
	CMP	#10,D0			;     if digit > 9
	BLT.S	@1			;     adjust for radix>10 values
	SUBI.B	#7,D0			;     and test again
	CMP	#10,D0
	BLT.S	@2
    @1:	CMP	NBase-base(BP),D0	;     if base < digit
	BGE.S	@2			;     FAIL
	MULU	NBase-base(BP),D4	;     multiply value by base
	ADD	D0,D4			;     add current digit
	SUBQ.B	#1,D1			;     decrement count
	BNE.S	digit			; UNTIL no digits remain
    	BCLR    #7,fneg-base(BP)	; test and clear negative flag
	BEQ.S	@0			; if set
	NEG	D4			; Negate it
    @0:	MOVE	D4,-(PS)		; push number
	MOVE	#-1,-(PS)		; push success flag
	BRA.S	@3
    @2:	CLR	-(PS)			; push fail flag
    @3:	MOVE.L	(SP)+,D4		; restore the register
	RTS

	DC.B	7,'FNU'			; FNUMBER ( dabs.addr -- f )
	DC.W	number-theLink		; convert string at dabs.addr to fp
fnum:	MOVE.L	(PS)+,-(RS)
	MOVE	#1,-(PS)
	PEA	(PS)
	PEA	$14(DP)
	CLR	-(PS)
	PEA	(PS)
	FPSTR2DEC
	ADDQ.L	#4,PS
	CMPI	#$054E,24(DP)		; check for NAN##
	BNE.S	@0
	JMP	whazat-base(BP)
    @0:	PEA	$14(DP)
	SUBQ.L	#6,PS
	SUBQ.L	#4,PS
	PEA	(PS)
	FDEC2X
	RTS
    
	DC.B	7,'EXE'			; "execute" ( cfa -- ) do a routine
	DC.W	fnum-theLink		;    whose cfa is on the stack
EXECUTE	MOVE	(PS)+,D0		; pop code address
	JMP	0(BP,D0.W)		; execute & return

	DC.B	8,'MCO'			; "mcompile" ( cfa -- ) 
	DC.W	Execute-theLink		; compile subroutine bodies inline 
MComp:	MOVE	(PS)+,D0
	LEA	0(BP,D0.W),A0		; addr of word
    @0:	MOVE	(A0)+,D0
	CMPI	#$4E75,D0		; if its an RTS your done
	BEQ.S	@1
	MOVE	D0,(A2)+		; if not, compile it
	BRA.S	@0			; do next word
    @1:	RTS
	
	DC.B	128+9,'[CO'		; "[compile]" ( -- )  compile
	DC.W	mcomp-theLink		;   the next immediate word
bCompile:
	JSR	tick-base(BP)		; get the cfa of the next word
	bra.s	compile			;  and compile a JSR to it
	
	DC.B	7,'COM'			; "compile" ( cfa -- ) compile a 
	DC.W	bcompile-theLink		;    call to the cfa on the stack
COMPILE	MOVE	#$04EAB,(DP)+		; compile "JSR d(A3)"
	BRA.S	Comma			; compile displacement value

	DC.B	9,'IMM'			; "immediate" ( -- ) make the last
	DC.W	compile-theLink		;   word defined immediate
IMMED	BSET	#7,0(BP,Dict.W)		; set immediate bit of most recent word
	RTS

	DC.B	5,'MAC'			; "macro" ( -- ) make the last
	DC.W	immed-theLink		;   word defined an inline macro
marco:	BSET	#6,0(BP,Dict.W)		; set macro bit of most recent word
	RTS

	DC.B	1,':',0,0		; ":" ( -- ) make a header for a 
	DC.W	marco-theLink		;   word definition
COLON	JSR	token-Base(BP)		; make header
	JSR	header-base(BP)
	BRA.S	rbrack			; enter compile mode
	
	DC.B	129,']',0,0		; "]" ( -- ) enter compile mode
	DC.W	colon-theLink
rBrack:	BSET	#7,fcolon-base(BP)	; set colon flag
	RTS

	DC.B	129,';',0,0		; ";" ( -- ) end a word definition
	DC.W	rBrack-theLink
SEMI	MOVE	#$4E75,(DP)+		; compile "RTS"
	BRA.S	lbrack
	
	DC.B	129,'[',0,0		; "[" ( -- ) leave compile mode
	DC.W	semi-theLink
lBrack:	CLR.B	fcolon-base(BP)		; clear colon flag
	RTS
	
	DC.B	7,'LIT'			; "literal" compiling: ( n -- )
	DC.W	lBrack-theLink		;   executing: ( -- n )
LITERAL	MOVE	#$03D3C,(DP)+		; compile move #xxxx,-(PS)
	BRA.S	Comma			; compile constant

	DC.B    64+1,',',0,0		; "," ( n -- )
	DC.W    literal-theLink
COMMA	MOVE	(PS)+,(DP)+		; pop number to dictionary
	RTS

	DC.B	8,'FLI'		; FLITERAL ( comp: n5 n4 n3 n2 n1 -- |exec: -- n5 n4 n3 n2 n1 )
	DC.W	comma-theLink
flit:	MOVE	(PS),D0
	MOVE	2(PS),D1
	MOVE	8(PS),(PS)
	MOVE	6(PS),2(PS)
	MOVE	D0,8(PS)
	MOVE	D1,6(PS)
	MOVEQ	#4,D0
    @0:	bsr.s	literal
	DBRA	D0,@0
	RTS

	DC.B	128+2,',$',0		; ",$" ( -- )
	DC.W	flit-theLink		; compile a hex number from input
CommaH:	MOVE	NBase-base(BP),-(RS)
	MOVE	#$10,nbase-base(BP)
	JSR	token-base(BP)
	BSR.S	here
	JSR	number-base(BP)
	MOVE	(RS)+,nbase-base(BP)
	TST	(PS)+
	BEQ	whazat
	BRA.S	comma

	DC.B	4,'HER'			; "here" ( -- addr )
	DC.W	commah-theLink		;   rel.addr of compile point
here: 	MOVE.L	DP,-(PS)
	BRA.S	torel

	DC.B	8,'DLI'			; "dliteral" compiling: ( d -- )
	DC.W	here-theLink		;   executing: ( -- d )
DLit:	MOVE	#$2D3C,(DP)+		; compile move.l #xxxx,-(PS)
	MOVE.L	(PS)+,(DP)+		; compile double number
	RTS

	DC.B	4,'>RE'			; ">rel" (to-rel) ( rel.uu) (rel.ah)
	DC.W	dlit-theLink		; ( daddr32 -- addr16 )
toRel:	MOVE.L	(PS)+,D0		; get the Daddr32 from stack
	SUB.L	BP,D0			; get difference from base addr
	MOVE	D0,-(PS)		; push the 16 bit part of it
	RTS

	DC.B	5,'COU'			; "count" ( addr -- addr+1 length )
	DC.W	torel-theLink
Count:	CLR	D1
	MOVE	(PS),D0
	MOVE.B	0(BP,D0.W),D1
	ADDQ	#1,(PS)
	MOVE	D1,-(PS)
	RTS

	DC.B	64+3,'+MD'		; "+MD" ( offset -- addr )
	DC.W	count-theLink
MacDat:	ADDI	#theWindow-base,(PS)	; add data addr to stacked offset
	RTS
	
	DC.B	4,'PAG'			; "page" ( -- )
	DC.W	macdat-theLink		; clear the window
Page:	PEA	WContRect-base(BP)	; The visable part of the window.
	_EraseRect
	MOVE.l	#$90001,-(SP)
	_MoveTo				; set pen position to home (1,9)
	_PenNormal			; 1X1, black, patcopy
	MOVE.l	#$40000,-(SP)
	_TextFont			; Monaco
	_TextFace			; plain text
	MOVE.l	#$90000,-(SP)
	_TextSize			; 9 point
	_TextMode			; srcCopy
	RTS

	DC.B	4,'BEE'			; "beep" ( -- )
	DC.W	page-theLink
Beep:	MOVE.W	#3,-(SP)
	_SysBeep
	RTS

	DC.B	64+3,'MON'		; "mon" ( -- ) execute _Debugger
	DC.W	beep-theLink
Mon:	_DeBugger
	RTS

TexD:	DC.W	'TEXT'

	DC.B	4,'OPE'		; "open" ( -- )
	DC.W	mon-theLink
Open:	MOVE.L	#$4B0037,-(SP)		; point: 75,55
	CLR.L	-(SP)			; no prompt
	CLR.L	-(SP)			; no filter
	MOVE	#1,-(SP)		; 1 type
	PEA	texd-base(BP)
	CLR.L	-(SP)			; no hook
	PEA	(A2)			; put sfreply at here
	MOVE	#2,-(SP)
	_Pack3
	TST	(A2)			; check 'good' field
	BEQ.S	beep			; beep if cancel

	MOVE	6(A2),-(PS)		; hold the vrefnum on stack
	CLR	D0
    @0:	MOVE.L	10(A2,D0.W),0(A2,D0.W)	; move the file name to 'here'
	ADDQ	#4,D0
	CMP	#32,D0
	BLE.S	@0
	BRA.S	load1
	
	DC.B	3,'-->'			; "-->" ( -- )
	DC.W	open-theLink
Load:	JSR	token-base(BP)		; put filename string at here
	CLR	-(PS)			; set vrefnum to 0 (path is specified)
 load1:	MOVE	fsptr-base(BP),D0	; get file stack pointer
	BMI	@0			;  ... save the offset into text ...
	LEA	fofsets-base(BP),A0	;  ... at fofsets+fspointer
	MOVE.L	TextO-base(BP),0(A0,D0)
	LEA	fends-base(BP),A0	;  TextE at fends+fspointer
	MOVE.L	TextE-base(BP),0(A0,D0)
    @0:	ADDQ	#4,fsptr-base(BP)	; increment the file stack pointer
	
	MOVE.L	#80,D0			; create an 80 byte block for
	DC.W	$A31E	; _NewPtr ,CLEAR - the file control buffer
	MOVE.L	A0,A4			; save it for later
	MOVE.B	#1,27(A0)		; set read only permission
	MOVE.L	DP,18(A0)		; set name pointer
	MOVE	(PS)+,22(A0)		; set vrefnum (working directory)
	DC.W	$A100	; _HOpen the file
	TST	16(A0)
	BNE.S	derror
	_GetEOF				; get ...
	MOVE.L	28(A0),36(A0)		;  ... and set ...
	MOVE.L	28(A0),-(PS)		;  ... and hold the file size
	
	MOVE.L	(PS),D0			; set block size = file size
	_NewHandle
	BMI.S	derror
	
	MOVE	fsptr-base(BP),D0	; get file stack pointer
	LEA	fstack-base(BP),A1	; file stack address
	MOVE.L	A0,0(A1,D0.W)		; stash the handle at fstack+(fsptr)
	_HLock
	
	MOVE.L	(A0),A0			; get start addr of block
	MOVE.L	A0,TextO-base(BP)	; set buffer start
	MOVE.L	A0,D0			; set buffer end ...
	ADD.L	(PS)+,D0
	MOVE.L	D0,TextE-base(BP)	;  ... to start + size
	
	MOVE.L	A4,A0
	MOVE.L	TextO-base(BP),32(A0)	; set read buffer addr in fcb
	_Read				; read data from file ...
	TST	16(A0)			; ... to scrap buffer
	BNE	derror
	_Close
	_DisposPtr
	JMP	go-base(BP)		; interpret scrap buffer

DError:	MOVE	16(A0),-(PS)
	_Close
	_DisposPtr
	JSR	pquote-base(BP)
	DC.B	10,'I/O Error:',0	; print the error messsage
	JSR	dot-base(BP)		; report the error number
	JMP	huh-base(BP)

	DC.B	8,'?GE'		; "?GESTALT"
	DC.W	load-theLink	; ( d.selector -- d.response true or false )
QGestalt:		; false if 64K ROM or no _Gestalt or bad selector
	; check for 64K ROM
	MOVE	#$A86E,D0		; _InitGraf
	_GetTrapAddress.newTool
	MOVE.L	A0,D1
	MOVE	#$AA6E,D0		; _InitGraf AND $200
	_GetTrapAddress.newTool
	CMP.L	A0,D1
	BEQ.S	gser1			; 64KROM

	; Check for gestalt
	MOVE.W	#$A89F,D0		; _Unimplemented
	_GetTrapAddress.newTool		; NGetTrapAddress
	MOVE.L	A0,D1
	MOVE.W	#$A1AD,D0		; _Gestalt
	_GetTrapAddress.newOS		; NGetTrapAddress
	CMP.L	A0,D1
	BEQ.S	gser1			; no gestalt

	; run gestalt
	MOVE.L	(PS)+,D0
	_Gestalt
	BNE.S	gser2
	MOVE.L	A0,-(PS)		; return the result  ... and ...
	MOVE	#-1,-(PS)		; return true
 gsret:	RTS

 gser1:	ADDQ.L	#4,PS			; gestalt error
 gser2:	CLR	-(PS)			; return false
	RTS

	DC.B	128+2,',S',0		; ",S" compile a dnumber from ascii
	DC.W	qgestalt-theLink	; NOTE: 1 and only 1 space seperates
CommaS:	;	move.l	(is)+,-(ps)	; this word from its data.
	MOVE.L	A2,A0
	MOVEQ	#4,D0
    @0:	MOVE.B	(IS)+,(A0)+
	DBRA	D0,@0
	MOVE.L	(A2),-(PS)

	TST.B	fcolon-base(BP)
	BEQ.S	gsret
	JMP	dlit-base(BP)

	DC.B	64+9,'INT'		; "interpret" ( -- )
	DC.W	commas-theLink
Interp:	JMP	main-base(BP)
	RTS

	
GRet:	LEA	Bottom,BP		; reset the base pointer
  	LEA	0(BP,D1.W),DP		; abs.addr into register
	LEA	0(BP,D2.W),IS
	JSR	toabs-base(BP)
	MOVE.L	(PS)+,(RS)
	RTS

	DC.B	4,'GRO'			; "grow" ( bytes -- )
	DC.W	interp-theLink		; enlarge the dictionary headroom
Grow:	JSR	here-base(BP)
	MOVE	(PS)+,D1		; hold rel DP in D1
	MOVE.L	IS,-(PS)
	JSR	torel-base(BP)
	MOVE	(PS)+,D2
	MOVE.L	(RS),-(PS)
	JSR	torel-base(BP)
	JSR	swapp-base(BP)
	MOVEA.L	expand-base(BP),A0
	JMP	(A0)			; JSR won't return here

	DC.B	4,'ROO'			; "room" ( -- bytes )
	DC.W	grow-theLink
Room:	LEA	Bottom,A0		; version 3+ use (PC) addressing
	_RecoverHandle			; use handle rather than pointer
	_GetHandleSize
	LEA	Bottom,A0		; Bottom ... version 3+ use (PC) addressing
	ADDA.L	D0,A0			;  +  block size ...
	SUBA.L	A2,A0			;  -  end of dictionary
	MOVE	A0,-(PS)		;  =  unused dictionary space
	RTS

	
	DC.B	4,'SAV'			; "save" ( -- ) save the dictionary
	DC.W	room-theLink
Save:	JSR	here-base(BP)
	MOVE	(PS)+,freePt-base(BP)	; save current DP
	MOVE	Dict,DictPt-base(BP)	; save current DictPt
	BSR.S	room
	MOVE	(PS),freesz-base(BP)	; save current headroom
	JSR	negate-base(BP)
	BSR.S	grow			; reduce headroom to 4 bytes
	LEA	Bottom,A0		; version 3+ use (PC) addressing
	_RecoverHandle			; get DICT's handle
	CLR	-(SP)
	MOVE.L	A0,-(SP)		; push 2, 1 for each operation
	MOVE.L	A0,-(SP)
	_ChangedResource
	_HomeResFile
	_UpdateResFile			; write out the DICT
	MOVE	freesz-base(BP),-(PS)
	BRA.S	grow			; restore headroom

	DC.B	4,'>AB'			; ">abs" (to-abs)
	DC.W	save-theLink		; ( addr16 -- daddr32 )
toAbs:	CLR.L	D0
	MOVE	(PS)+,D0		; pop rel addr
	LEA	0(BP,D0.W),A0		; calc as offset to base ...
	MOVE.L	A0,-(PS)		; ...  and push
	RTS

	DC.B	64+6,'NEG'		; "negate" ( n -- -n )
	DC.W	toabs-theLink
negate:	NEG	(PS)
	RTS

	DC.B	5,'SPA'			; "space" ( -- ) emit a space
	DC.W	negate-theLink
space:	MOVE.L	#32,D0
	jmp	EmitCode-Base(BP)

	DC.B	4,'TYP'			; "type" ( rel.addr len -- )
	DC.W	space-theLink		;  emit len characters from rel.addr
Type:	MOVEM.L	D3/D4,-(SP)		; don't trash registers!
	MOVE	(PS)+,D3		; get character count
	SUBQ	#1,D3			;    ( fixed bug )
	MOVE	(PS)+,D4		; get string relative address
    @0:	MOVE.B	0(BP,D4.W),D0		; get character byte
	jsr	EmitCode-Base(BP)	; print character byte
	ADDQ	#1,D4
	DBRA	D3,@0
	MOVEM.L	(SP)+,D3/D4		; restore registers
	rts

pQuote:	;   runtime part of ."
	MOVE.L	(RS),-(PS)		; push the addr of the string
	JSR	torel-base(BP)
	ADDQ	#1,(PS)			; skip the length byte
	MOVE.L	(RS),A0
	CLR.L	D0			; clear the character count
	MOVE.B	(A0),D0			; get the length
	MOVE	D0,-(PS)		; push it
	ADDQ	#2,D0
	ANDI	#$FFFE,D0		; be sure its even
	ADD.L	D0,(RS)			; skip over string upon return
	bra.s	type	;-base(BP)		; type the string
	
	DC.B	4,'EMI'			; "emit" ( n -- ) send the ascii
	DC.W	type-theLink	;                 to the terminal
Emit:	MOVE	(PS)+,D0
  EmitCode:				; Emit contents of D0
	CMP.B	#13,D0			; is it a <cr>
	BEQ.S	doCR
	CMP.B	#8,D0			; is it a <del>?
	BEQ.S	doDEL
	ANDI	#$FF,D0
	MOVE	D0,-(A7)
	_DrawChar
	BSR.S	penh
	MOVE	WContRect+6-base(BP),D0	; right coord of WContRect
	CMP	D0,D1			; is the position beyond the edge
	BLS.S	emitr			; no
	
  doCR:	PEA	Scratch-base(BP)
	_GetPen
	MOVE	Scratch-base(BP),D1
	MOVE	WContRect+4-base(BP),D0	; bottom coord of WContRect
	SUB	#11,D0
	CMP	D0,D1			; is the position below the window
	BLS.S	@0			; no

	; yes it is below the bottom of the window, so scroll up 11 pixels
	CLR.L	-(A7)			; Make room for a region handle.
	_NewRgn				; get handle into (A7)
	PEA	WContRect-base(BP)	; rect to scroll
	CLR	-(A7)			; no horiz.
	MOVE	#$FFF5,-(A7)		; 11 pix. vert.
	MOVE.L	8(A7),-(A7)		; push the region handle
	_ScrollRect
	_DisposRgn

	MOVE	WContRect+4-base(BP),D1	; bottom coord of WContRect
	SUBQ	#4,D1
	BRA.S	@1

    @0: ADD	#11,D1			; Add line height to pen location
    @1:	MOVE	#1,-(A7)
	MOVE	D1,-(A7)
	_MoveTo
 emitr:	RTS

 doDEL:	BSR.S	penh
	CMP	#6,D1			; first column?
	blt.s	@0			; don't beep anymore
	SUB	#6,D1			; back up
	MOVE	D1,-(SP)
	MOVE	Scratch-base(BP),-(SP)
	_MoveTo
    @0:	RTS

  penh:	PEA	Scratch-base(BP)
	_GetPen
	MOVE	Scratch+2-base(BP),D1
	RTS

	DC.B	6,'EXP'			; "expect" ( addr count -- )
	DC.W	emit-theLink
Expect:	MOVEM.L	D4/IS,-(SP)
	JSR	swapp-base(BP)		; leave number of chars on stack
	MOVE	(PS)+,D0		; addr
	LEA	0(BP,D0.W),IS		; set IS to the input address
	CLR	Counter
	MOVE	(PS)+,D4
    @0:	JSR	key-base(BP)
	MOVE	(PS)+,D5
	CMPI	#CR,D5			; if key = CR
	BNE.S	@1
	MOVE.B	#BL,0(IS,Counter)
	CLR.B	1(IS,Counter)
	MOVE.B	#BL,2(IS,Counter)
	BRA.S	@3
    @1:	CMPI	#BS,D5			; if key = backspace
	BNE.S	@2
	TST	Counter			; do nothing if first key is BS
	BEQ.S	@0
	SUBQ	#1,Counter		; decriment counter
	JSR	dodel-base(BP)
	JSR	space-base(BP)		;    ... rubout char
	JSR	dodel-base(BP)
	BRA.S	@0
    @2:	MOVE.B	D5,0(IS,Counter)	; stash the key into input buffer
	ADDQ	#1,Counter
	MOVE	D5,D0
	JSR	emitcode-base(BP)
	CMP	D4,Counter		; is count=number of chars to get?
	BNE.S	@0
    @3:	JSR	docr-base(BP)
	MOVEM.L	(SP)+,D4/IS
	RTS

	DC.B	64+1,'0',0,0		; "0" ( -- 0 )
	DC.W	expect-theLink
Zero:	CLR	-(PS)
	RTS
	
	DC.B	64+4,'DRO'		; "drop" ( n -- )
	DC.W	zero-theLink
drop:	ADDQ.L	#2,PS
	RTS

	DC.B	4,'SWA'			; "swap" ( n1 n2 -- n2 n1 )
	DC.W	drop-theLink
swapp:	MOVE.L	(PS)+,D0
	SWAP	D0
	MOVE.L	D0,-(PS)
	RTS

	DC.B	64+5,'2DR'		; "2drop" ( d -- )
	DC.W	swapp-theLink
TwoDrop:
	ADDQ.L	#4,PS
	RTS

	DC.B	4,'NUL'			; "null" ( -- )
	DC.W	twodrop-theLink
Null:	RTS

	DC.B	6,'FOR'			; "forget" ( -- ) forgets dictionary
	DC.W	null-theLink
Forget:	JSR	tick-base(BP)
	MOVE	(PS)+,D0
	MOVE	-2(BP,D0.W),Dict
	LEA	-6(BP,D0.W),DP
	RTS

	DC.B	8,'CON'			; "constant" compile: ( n16 -- )
	DC.W	forget-theLink	;            runtime: ( -- n16 )
Const:	JSR	token-base(BP)		; make a header for the next token
	JSR	header-base(BP)
	JSR	marco-base(BP)		; to return a constant
	JSR	literal-base(BP)	; compile time comma, runtime push
	MOVE	#$4E75,(DP)+		; compile  rts 
	RTS

	DC.B	6,'CRE'			; "create" compile: ( -- ) 
	DC.W	const-theLink		;          runtime: ( -- addr16 )
Create:	JSR	token-base(BP)		; give token this runtime action:
	JSR	header-base(BP)
	MOVE	#$3D3C,(DP)+		;  ¥ move     #nnnn,-(ps)
	JSR	here-base(BP)
	ADDQ	#6,(PS)
	MOVE	(PS)+,(DP)+		; supply the nnnn from above
	MOVE	#$4EEB,(DP)+		;  ¥ jmp     null-base(bp)
	MOVE.L	DP,DoesAddr-base(BP)	; set DoesAddr to this "null"
	MOVE	#null-base,(DP)+
	RTS

	DC.B	5,'DOE'			; "does>" ( -- ) (use after create)
	DC.W	create-theLink		;   set runtime action 
Does:	MOVE.L	(RS)+,D0		; pop the return address
	SUB.L	BP,D0			; convert to rel.addr
	MOVE.L	DoesAddr-base(BP),A0	; load jmp d(bp) address from create
	MOVE	D0,(A0)			; and stash rel.addr into it
	RTS				; returns same as ;

	DC.B	5,'ALL'			; "allot" ( n16 -- )
	DC.W	does-theLink		;  compiles nada into the dictionary
Allot:	ADDQ	#1,(PS)
	ANDI	#$FFFE,(PS)		; make it even!
	ADDA	(PS)+,DP		; increment the dictionary pointer
	RTS

	DC.B	8,'VAR'			; "variable" compile: ( -- )
	DC.W	allot-theLink		;            runtime: ( -- addr16 )
Variable:
	JSR	token-base(BP)		; give token this runtime action:
	JSR	header-base(BP)
	JSR	marco-base(BP)		; Sun May 1, 1988 04:24:44
	MOVE	#$3D3C,(DP)+		;  ¥ move   #nnnn,-(ps)
	JSR	here-base(BP)
	ADDQ	#4,(PS)			;    calculate nnnn
	MOVE	(PS)+,(DP)+		;  ¥ (this is the nnnn)
	MOVE	#$4E75,(DP)+		;  ¥ rts
	ADDQ.L	#2,DP			; 2 allot
	RTS

	DC.B	64+5,'>NA'		; ">name" ( 'addr -- name.addr )
	DC.W	variable-theLink
toname:	SUBQ	#6,(PS)
	RTS
	
	DC.B	64+5,'>LI'		; ">link" ( 'addr -- link.addr )
	DC.W	toname-theLink
tolink:	SUBQ	#2,(PS)
	RTS

	DC.B	3,'ID.'			; "id." ( addr -- )
	DC.W	tolink-theLink
IDDot:	JSR	toname-base(BP)
	MOVEA.L	DP,A0
	MOVEQ.L	#5,D0
    @0:	MOVE.L	#$C9C9C9C9,(A0)+	
	DBRA	D0,@0
	MOVE	(PS)+,D0
	MOVE.L	0(BP,D0.W),(DP)
	JSR	here-base(BP)
	MOVE	(PS),-(PS)
	JSR	cat-base(BP)
	ANDI	#$1F,(PS)		; look at 5 lsb's
	ADDQ	#1,2(PS)
	JSR	type-base(BP)
	JMP	space-base(BP)
	
	DC.B	5,'WOR'			; "words" ( -- ) list words
	DC.W	iddot-theLink
Words:	MOVE.L	D3,-(SP)		; preserve register
	MOVE	Dict,D3			; start with the last word defined
    @0:	MOVE	D3,-(PS)		; push the name address
	ADDQ	#6,(PS)			; get the CFA
	BSR.S	iddot			; print the name
 	MOVE	4(BP,D3.W),D3		; put the next name addr into D3
	TST.B	1(BP,D3.W)		; Quit if name is 0
	BEQ.S	@1			; do next word if not=0
	JSR	qterm-base(BP)
    	TST	(PS)+
	BEQ.S	@0
    @1:	MOVE.L	(SP)+,D3		; restore register
	RTS
	
	DC.B	3,'PAD'			; "pad" ( -- ) conversion pad
	DC.W	words-theLink
Pad:	JSR	here-base(BP)
	ADDI	#40,(PS)		; pad is 40 bytes from HERE.
	RTS
	
	DC.B	4,'HOL'			; "hold" ( c -- ) place c at ...
	DC.W	pad-theLink		; ... addr in Held.
Hold:	SUBQ	#1,held-base(BP)
	MOVE	held-base(BP),-(PS)
	JMP	cstore-base(BP)
	
	DC.B	4,'SIG'			; "sign" ( sf dval -- dval )
	DC.W	hold-theLink
Sign:	JSR	rote-base(BP)
	TST	(PS)+
	BGE.S	@0
	MOVE	#'-',-(PS)
	BSR.S	hold
    @0:	RTS

	DC.B	4,'DAB'			; "dabs" ( dval -- |dval| )
	DC.W	sign-theLink
Dabs:	TST	(PS)
	BGE.S	@0
	JSR	dneg-base(BP)
    @0:	RTS

	DC.B	2,'<#',0		; "<#" ( -- )
	DC.W	dabs-theLink
LSharp:	BSR.S	pad
	MOVE	(PS)+,held-base(BP)
	MOVEA.L	DP,A0
	MOVE	#9,D0
    @0:	CLR.L	(A0)+
	DBRA	D0,@0
	MOVE	#30,-(PS)
	BRA.S	hold

	DC.B	2,'#>'.0		; "#>" ( dval -- addr len )
	DC.W	lsharp-theLink
SharpG:	ADDQ.L	#2,PS
	MOVE	held-base(BP),(PS)
	BSR.S	pad
	MOVE	2(PS),-(PS)		; over
	ADDQ	#1,(PS)
	JMP	minus-base(BP)
	
	DC.B	1,'#',0,0		; "#" ( dval -- d/base )
	DC.W	sharpg-theLink
Sharp:	MOVE	NBase-base(BP),-(PS)
	JSR	msmod-base(BP)
	JSR	rote-base(BP)
	CMPI	#9,(PS)			; is top of stack < 9?
	BLE.S	@0
	ADDQ	#7,(PS)
    @0:	ADDI	#48,(PS)
	JMP	hold-base(BP)

	DC.B	2,'#S',0		; "#s" ( dval -- 0 0 )
	DC.W	sharp-theLink
Sharps:	BSR.S	sharp
	TST.L	(PS)
	BNE.S	sharps
	RTS

	DC.B	2,'D.',0		; "d." ( dval -- )
	DC.W	sharps-theLink
DDot:	JSR	swapp-base(BP)
	MOVE	2(PS),-(PS)
	JSR	dabs-base(BP)
	BSR.S	lsharp
	BSR.S	sharps
	JSR	sign-base(BP)
	BSR.S	sharpg
	jsr	type-base(BP)
	jmp	space-base(bp)

	DC.B	2,'U.',0		; "u." ( uval -- )
	DC.W	ddot-theLink
UDot:	CLR	-(PS)
	BRA.S	ddot

	DC.B	3,'S>D'			; "s>d" ( n -- d )
	DC.W	udot-theLink
SToD:	MOVE	(PS),-(PS)		; dup
	JMP	zerolt-base(BP)		; 0<

	DC.B	1,'.',0,0		; "." ( n -- )
	DC.W	stod-theLink
Dot:	BSR.S	stod
	BRA.S	ddot

	DC.B	130,'."',0		; "."" ( -- ) compiler part of (.")
	DC.W	dot-theLink
dotQ:	MOVE	#pQuote-base,-(PS)
	JSR	compile-base(BP)	; compile a call to (.")
	JSR	here-base(BP)		; ( -- addr )
	MOVE	#'"',-(PS)		; ( -- addr 34 )
	JSR	word-base(BP)		; ( -- addr )
	JSR	cat-base(BP)		; ( -- c )
	ADDQ	#1,(PS)			; ( -- c+1 )
	JMP	allot-base(BP)		; enclose the string in dictionary
	
	DC.B	129,'(',0,0		; "(" ( -- ) begin comment
	DC.W	dotq-theLink
Comment	CMPI.B	#41,(IS)+		; read in characters until ")"
	BNE.S	Comment
	RTS

	DC.B	5,'CMO'			; "cmove" ( addr1 addr2 len -- )
	DC.W	comment-theLink		; from figFORTH, fixed 8/3/91
CMove:	MOVE	(PS)+,D0		; D0 = length
	MOVE	(PS)+,D1
	LEA	0(BP,D1.W),A1		; A1 = addr2
	MOVE	(PS)+,D1
	LEA	0(BP,D1.W),A0		; A0 = addr1
	CMPA.L	A0,A1
	BPL.S	@2

	BRA.S	@1			;  addr1 > addr2
    @0:	MOVE.B	(A0)+,(A1)+
    @1:	DBRA	D0,@0
	RTS

    @2:	ADDA	D0,A0			;  addr1 ² addr2
	ADDA	D0,A1
	BRA.S	@4
    @3:	MOVE.B	-(A0),-(A1)
    @4:	DBRA	D0,@3
	RTS
	
	DC.B	4,'FIL'			; "fill" ( addr count char -- )
	DC.W	cmove-theLink
Fill:	MOVE	(PS)+,D0		; character
	MOVE	(PS)+,D1		; count
	SUBQ	#1,D1			; decrement count
	MOVE	(PS)+,A0		; relative addr
	LEA	0(BP,A0.W),A0		; get absolute addr
    @0:	MOVE.B	D0,0(A0,D1.W)		; put char into addr + count
    	DBRA	D1,@0			; decrement count & loop until 0
	RTS
	
	DC.B	9,'-TR'			; "-trailing"
	DC.W	fill-theLink		;  ( addr count -- addr new.count )
dtrail:	MOVE	(PS)+,D1		; get the count
	MOVE	(PS),D0			; get the rel.addr
	LEA	0(BP,D0.W),A0		; get the abs.addr
    @0:	CMPI.B	#$20,-1(A0,D1.W)	; BEGIN  is char at addr+count $20
	DBNE	D1,@0			; NOT UNTIL
	MOVE	D1,-(PS)		; put new count on stack
	RTS
	
	DC.B	64+2,'1+',0		; "1+" ( n -- n+1 )
	DC.W	dtrail-theLink
OnePl:	ADDQ	#1,(PS)
	RTS

	DC.B	64+2,'1-',0		; "1-" ( n -- n-1 )
	DC.W	onepl-theLink
OneMi:	SUBQ	#1,(PS)
	RTS
	
	DC.B	64+2,'2+',0		; "2+" ( n -- n+2 )
	DC.W	onemi-theLink
TwoPl:	ADDQ	#2,(PS)
	RTS
	
	DC.B	64+2,'2*',0		; "2*" ( n -- n*2 )
	DC.W	twopl-theLink
ToStar:	ASL	(PS)
	RTS

	DC.B	64+2,'2/',0		; "2/" ( n -- n/2 )
	DC.W	tostar-theLink
ToDiv:	ASR	(PS)
	RTS

	DC.B	5,'DEP'			; "depth" ( -- n )
	DC.W	ToDiv-theLink		; 16 bit entries on stack before this
depth:	move.l	szero-base(bp),d0
	sub.l	ps,d0
	move	d0,-(ps)
	bra.s	todiv

	DC.B	1,'@',0,0		; "@" (at) ( addr16 -- n16 )
	DC.W	depth-theLink
At:	MOVE	(PS),D0			; DANGER: odd values crash this
	MOVE	0(BP,D0.W),(PS)	
	RTS

	DC.B	1,'!',0,0		; "!" (store) ( n16 addr16 -- )
	DC.W	at-theLink
Store:	MOVE	(PS)+,D0		; DANGER: odd values crash this
	MOVE	(PS)+,0(BP,D0.W)
	RTS

	DC.B	2,'C!',0		; "c!" (sea-store)( n8 addr16 -- )
	DC.W	store-theLink
CStore:	MOVE	(PS)+,D0		; get the rel.addr (odd OK)
	ADDQ.L	#1,PS			; align the stack
	MOVE.B	(PS)+,0(BP,D0.W)	; put data at the addr
	RTS

	DC.B	2,'C@',0		; "c@" (sea-at) ( addr16 -- n8 )
	DC.W	cstore-theLink
CAt:	MOVE	(PS),D0			; get rel.addr (odd OK)
	CLR	(PS)			; clear the result
	MOVE.B	0(BP,D0.W),1(PS)	; stash the second byte
	RTS

	DC.B	64+2,'L@',0		; "l@" (el-at) ( daddr32 -- n16 )
	DC.W	cat-theLink
LAt:	MOVEA.L	(PS)+,A0		; get the double number "real" addr
	MOVE	(A0),-(PS)		; fetch the contents
	RTS

	DC.B	64+2,'L!',0		; "l!" (el-store)( n16 daddr32 -- )
	DC.W	lat-theLink
LStore:	MOVEA.L	(PS)+,A0
	MOVE	(PS)+,(A0)
	RTS
	
	DC.B	64+3,'DL@'		; "dl@" ( daddr32 -- d32 )
	DC.W	lstore-theLink
DLAt:	MOVEA.L	(PS),A0
	MOVE.L	(A0),(PS)
	RTS
	
	DC.B	64+3,'DL!'		; "dl!" ( d32 daddr32 -- )
	DC.W	dlat-theLink
DLStor:	MOVE.L	(PS)+,A0
	MOVE.L	(PS)+,(A0)
	RTS

	DC.B	2,'+!',0		; "+!" ( n16 addr16 -- )
	DC.W	dlstor-theLink
pstore:	MOVE	(PS)+,D0
	MOVE	(PS)+,D1
	ADD	D1,0(BP,D0.W)
	RTS
	
	DC.B	64+4,'CBL'		; "cblk" ( -- addr ) of fint
	DC.W	pstore-theLink
cBLK:	MOVE	#fint-base,-(PS)
	RTS
	
	DC.B	64+6,'CST'		; "cstate" ( -- addr ) of fcolon
	DC.W	cblk-theLink
cState:	MOVE	#fcolon-base,-(PS)
	RTS

	DC.B	64+4,'BAS'		; "base" ( -- addr )
	DC.W	cstate-theLink		;   variable for the numeric radix
BaseA:	MOVE	#nbase-base,-(PS)
	RTS

	DC.B	64+3,'TIB'		; "tib" ( -- addr )
	DC.W	basea-theLink		;   variable for Terminal Input Buf.
TIB:	MOVE	#termbuf-base,-(PS)
	RTS

	DC.B	64+6,'LAT'		; "latest" ( -- addr )
	DC.W	tib-theLink		;   variable for the last dict word
Latest:	MOVE	Dict,-(PS)		; push contents of the dict register
	RTS

	DC.B	64+3,'R0@'		; "r0@" ( -- dabs.addr )
	DC.W	latest-theLink		;   dabs.addr of r0
R0at:	MOVE.L	rzero-base(BP),-(PS)
	RTS

	DC.B	64+3,'RP@'		; "rp@" ( -- dabs.addr )
	DC.W	r0at-theLink		;   current addr of the return stack
RPat:	MOVE.L	RS,-(PS)
	RTS

	DC.B	64+3,'S0@'		; "s0@" ( -- dabs.addr )
	DC.W	rpat-theLink		;   dabs.addr of s0
S0at:	MOVE.L	szero-base(BP),-(PS)
	RTS

	DC.B	64+3,'SP@'		; "sp@" ( -- dabs.addr )
	DC.W	s0at-theLink		; address of the current stack cell
SPat:	MOVE.L	PS,-(PS)
	RTS

	DC.B	3,'HEX'			; "hex" ( -- )
	DC.W	spat-theLink
hex:	MOVE	#$10,nbase-base(BP)
	RTS

	DC.B	7,'DEC'			; "decimal" ( -- )
	DC.W	hex-theLink
decimal	MOVE	#10,nbase-base(BP)
	RTS
	
	DC.B	4,'?DU'			; "?dup" ( n -- n n OR n [if n=0] )
	DC.W	decimal-theLink
qdup:	TST	(PS)
	BNE.S	dup
	RTS

	DC.B	64+3,'DUP'		; "dup" ( n -- n n )
	DC.W	qdup-thelink
dup:	MOVE	(PS),-(PS)
	RTS

	DC.B	64+4,'OVE'		; "over" ( n1 n2 -- n1 n2 n1 )
	DC.W	dup-theLink
over:	MOVE	2(PS),-(PS)
	RTS

	DC.B	3,'ROT'			; "rot" ( n1 n2 n3 -- n2 n3 n1 )
	DC.W	over-theLink
rote:	MOVE.L	(PS)+,D0
	MOVE	(PS)+,D1
	MOVE.L	D0,-(PS)
	MOVE	D1,-(PS)
	RTS

	DC.B	64+4,'2DU'		; "2dup" ( n1 n2 -- n1 n2 n1 n2 )
	DC.W	rote-theLink
todup:	MOVE.L	(PS),-(PS)
	RTS

	DC.B	5,'2SW'			; "2swap"
	DC.W	todup-theLink		;  ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
toswap:	MOVE.L	(PS)+,D0
	MOVE.L	(PS)+,D1
	MOVE.L	D0,-(PS)
	MOVE.L	D1,-(PS)
	RTS
	
	DC.B	64+2,'>R',0		; ">r" ( n -- ) rstack: ( -- n16 )
	DC.W	toswap-theLink
toR:	MOVE	(PS)+,-(RS)
	RTS

	DC.B	64+2,'R>',0		; "r>" ( -- n ) rstack: ( n16 -- )
	DC.W	tor-theLink
Rfrom:	MOVE	(RS)+,-(PS)
	RTS

	DC.B	64+1,'R',0,0		; "r" ( -- n ) rs: ( n16 -- n16 )
	DC.W	rfrom-theLink
Are:	MOVE	(RS),-(PS)
	RTS

	DC.B	4,'EXI'			; "exit" ( -- ) drops return address
	DC.W	are-theLink
Exit:	ADDQ.L	#4,RS
	RTS

	DC.B	1,'*',0,0		; "*" ( n1 n2 -- n1*n2 )
	DC.W	exit-theLink
times:	MOVE	(PS)+,D0
	MULS	(PS)+,D0
	MOVE	D0,-(PS)
	RTS

	DC.B	4,'/MO'			; "/mod ( n1 n2 -- rem quot )
	DC.W	times-theLink
Smod:	MOVE	(PS)+,D0
	BNE.S	@0
	BRA.S	sfail
    @0:	MOVE	(PS)+,D1
	EXT.L	D1
	DIVS	D0,D1
	SWAP	D1
	MOVE.L	D1,-(PS)
	RTS

	DC.B	1,'/',0,0		; "/" ( n1 n2 -- quotient )
	DC.W	smod-theLink
Slash:	JSR	smod-base(BP)
	JSR	swapp-base(BP)
	ADDQ.L	#2,PS
	RTS

	DC.B	3,'MOD'			; "mod"	( n1 n2 -- remainder )
	DC.W	slash-theLink
mod:	JSR	smod-base(BP)
	ADDQ.L	#2,PS
	RTS

	DC.B	2,'*/',0		; "*/" ( n1 n2 n3 -- n1*n2/n3 )
	DC.W	mod-theLink
SSlash:	MOVE	(PS)+,D1
	BNE.S	sok
	ADDQ.L	#2,PS
 sfail:	MOVE	#-1,(PS)
	RTS
   sok:	MOVE	(PS)+,D0
	MULS	(PS),D0
	DIVS	D1,D0
	MOVE	D0,(PS)
	RTS

	DC.B	2,'U*',0		; "u*" ( n1 n2 -- d32 )
	DC.W	sslash-theLink
UStar:	MOVE	(PS)+,D0
	MULU	(PS)+,D0
	MOVE.L	D0,-(PS)
	RTS
	
	DC.B	5,'M/M'			; "m/mod" from King&Knight
	DC.W	ustar-theLink		; ( num32 denom16 -- rem16 quot32 )
MSMod:	TST	(PS)			; test for div by zero
	BNE.S	@0
	ADDQ.L	#4,PS
	BRA.S	sfail
    @0:	MOVE.L	D2,-(SP)		; save D2
	MOVEQ	#0,D2			; clear it
	MOVE	(PS)+,D2		; pop denom into D2.W
	MOVE.L	(PS)+,D1		; pop num into D1.L
	MOVE	D1,-(SP)		; hold num.l on rstack
	CLR	D1
	SWAP	D1
	DIVU	D2,D1
	MOVE	D1,D0
	MOVE	(SP)+,D1
	DIVU	D2,D1
	SWAP	D1
	MOVE	D1,-(PS)		; push remainder
	MOVE	D0,D1
	SWAP	D1
	MOVE.L	D1,-(PS)		; push quotient
	MOVE.L	(SP)+,D2		; restore register
	RTS
	
	DC.B	64+7,'DNE'		; "dnegate" ( d32 -- -d32 )
	DC.W	msmod-theLink
DNeg:	NEG.L	(PS)
	RTS
	
	DC.B	64+2,'D+',0		; "d+" ( d1 d2 -- d1+d2 )
	DC.W	dneg-theLink
DPlus:	MOVE.L	(PS)+,D0
	ADD.L	D0,(PS)
	RTS
	
	DC.B	128+2,'IF',0		; "if" ( flag -- ) at runtime
	DC.W	dplus-theLink		;      ( -- addr ) at compile time
pIf:	MOVE.L	#$4A5E6700,(DP)+	; compile tst (ps)+  beq ...
  pi1:	bsr.s	pbegin
	ADDQ.L	#2,DP			; make room for offset
	RTS
	
	DC.B	128+5,'WHI'		; "while" ( flag -- ) at runtime
	DC.W	pif-theLink		;    ( -- addr ) at compile time
pWhile:	BRA.S	pIf
	
	DC.B	128+4,'ELS'		; "else" ( -- ) at runtime
	DC.W	pwhile-theLink		; ( addr -- addr ) at compile time
pElse:	MOVE	#$6000,(DP)+
	bsr.s	pi1
	JSR	swapp-base(BP)
	BRA.S	pthen

	DC.B	128+4,'THE'		; "then" ( -- ) at runtime
	DC.W	pelse-theLink		;   ( addr -- ) at compile time
pThen:	bsr.s	pbegin
	MOVE	2(PS),-(PS)		; over
	JSR	minus-base(BP)
	JSR	swapp-base(BP)
	JMP	store-base(BP)

	DC.B	128+6,'REP'		; "repeat" ( -- ) at runtime
	DC.W	pthen-theLink		; ( b.addr w.addr -- ) at c.time
pRepet:	MOVE	#$6000,(DP)+		; compile bra ...
	JSR	swapp-base(BP)
	BSR.S	back
	BRA.S	pThen			; HERE OVER - SWAP ! ;

	DC.B	128+5,'BEG'		; "begin" ( -- ) at runtime
	DC.W	prepet-theLink		;    ( -- addr ) at compile time
pBegin:	JMP	here-base(BP)

	DC.B	128+5,'UNT'		; "until" ( flag -- ) at runtime
	DC.W	pbegin-theLink		;      ( addr -- ) at compile time
pUntil	MOVE.L	#$4A5E6700,(DP)+	; compile tst (ps)+  beq ...
	BRA.S	back
	
	DC.B	128+5,'AGA'		; "again" ( -- ) at runtime
	DC.W	puntil-theLink		;    ( addr -- ) at compile time
pAgain:	MOVE	#$6000,(DP)+		; compile bra ...
	BRA.S	back

	DC.B	4,'BAC'			; "back" ( addr -- )
	DC.W	pagain-theLink		;  compile negative displacement
back:	bsr.s	pbegin
	JSR	minus-base(BP)
	MOVE	(PS),D0			; get the target addr into d0
	BGE.S	@0
	NEG	D0			; make it positive
    @0:	ANDI	#$FF80,D0		; if > 1 byte
	BEQ.S	@1
	JMP	comma-base(BP)		; then comma it as a long branch
    @1:	MOVE.B	1(PS),-1(DP)		; else make it a short branch
	JMP	drop-base(BP)

	DC.B	128+2,'DO',0		; "do" ( -- addr ) at compile time
	DC.W	back-theLink		;  ( limit index -- ) at runtime
do:	MOVE	#$2F1E,(DP)+		; ¥ move.l (ps)+,-(ps)
	bra.s	pbegin
	
	DC.B	128+4,'LOO'		; "loop" ( -- ) at runtime
	DC.W	do-theLink		;   ( addr -- ) at compile time
Loop:	MOVE.L	#$52573017,(DP)+	;  ¥ addq #1,(rs) ¥ move (rs),d0  (increment ix)
	MOVE.L	#$B06F0002,(DP)+	;  ¥ cmp  2(rs),d0 (check lim)
	MOVE	#$6B00,(DP)+		;  ¥ bmi  ...      (loop if ix<lim)
  pl:	BSR.S	back			; comma in the displacement to 'do'
	MOVE	#$588F,(DP)+		;  ¥ addq.l #4,rs    (drop ix&lim)
	RTS
	
	DC.B	128+5,'+LO'		; "+loop" ( n -- ) at runtime
	DC.W	loop-theLink		;   ( addr -- ) at compile time
pLoop:	MOVE	#$4EAB,(DP)+
	MOVE	#ppl-base,(DP)+		;  ¥ jsr ppl-base(bp)
	MOVE	#$6700,(DP)+		;  ¥ beq  ...  (neg flag change)
	BRA.S	pl

ppl:	MOVE	4(A7),D0		; get index
	CMP	6(A7),D0		; check limit
	MOVE	SR,D1			; hold result
	MOVE 	(PS)+,D0		; get step 
	ADD	D0,4(A7)		; incerment index
	MOVE	4(A7),D0		; get new index
	CMP	6(A7),D0		; check new limit
	MOVE	SR,D0			; hold it
	EOR	D0,D1			; mix with last result
	AND	#8,D1			; check for change in neg flag
	RTS
	
	DC.B	5,'LEA'			; "leave" ( -- )
	DC.W	ploop-theLink		;  set the index to the limit
Leave:	MOVE	6(RS),4(RS)
	RTS

	DC.B	2,'0<',0		; "0<" ( n -- flag )
	DC.W	leave-theLink
ZeroLT:	TST	(PS)
	BLT.S	true
 false:	CLR	(PS)
	RTS
 true:	MOVE	#-1,(PS)
	RTS

	DC.B	2,'0>',0		; "0>" ( n -- flag )
	DC.W	zerolt-theLink
ZeroGT:	NEG	(PS)
	BRA.S	zerolt

	DC.B	2,'0=',0		; "0=" ( n -- flag )
	DC.W	zerogt-theLink
ZeroEQ:	TST	(PS)
	BEQ.S	true
	BRA.S	false

	DC.B	64+1,'+',0,0		; "+" ( n1 n2 -- n1+n2 )
	DC.W	zeroeq-theLink
plus:	MOVE	(PS)+,D0
	ADD	D0,(PS)
	RTS

	DC.B	1,'-',0,0		; "-" ( n1 n2 -- n1-n2 )
	DC.W	plus-theLink
minus:	NEG	(PS)
	bra.s	plus

	DC.B	1,'=',0,0		; "=" ( n1 n2 -- flag )
	DC.W	minus-theLink
equal:	bsr.s	minus
	BRA.S	zeroeq

	DC.B	1,'<',0,0		; "<" ( n1 n2 -- flag )
	DC.W	equal-theLink
lesst:	bsr.s	minus
	BRA.S	zerolt

	DC.B	1,'>',0,0		; ">" ( n1 n2 -- flag )
	DC.W	lesst-theLink
moret:	bsr.s	minus
	BRA.S	zerogt

	DC.B	64+3,'AND'		; "and"	( n1 n2 -- n1(and)n2 )
	DC.W	moret-theLink
andd:	MOVE	(PS)+,D0
	AND	D0,(PS)
	RTS

	DC.B	64+2,'OR',0		; "or" ( n1 n2 -- n1(or)n2 )
	DC.W	andd-theLink
orr:	MOVE	(PS)+,D0
	OR	D0,(PS)
	RTS
	
	DC.B	64+3,'XOR'		; "xor" ( n1 n2 -- n1(xor)n2 )
	DC.W	orr-theLink
xor:	MOVE	(PS)+,D0
	EOR	D0,(PS)
	RTS

	DC.B	3,'ABS'			; "abs"	( n1 -- abs(n1) )
	DC.W	xor-theLink
abs:	TST	(PS)
	BGE.S	@0
	NEG	(PS)
    @0:	RTS

    	DC.B	3,'MIN'			; "min" ( n1 n2 -- n(min) )
	DC.W	abs-theLink
min:	MOVE	(PS)+,D0
	CMP	(PS),D0
	BLT.S	pd0
	RTS
   pd0:	MOVE	D0,(PS)
	RTS

    	DC.B	3,'MAX'			; "max" ( n1 n2 -- n(max) )
	DC.W	min-theLink
max:	MOVE	(PS)+,D0
	CMP	(PS),D0
	BGE.S	pd0
	RTS

	DC.B	2,'2@',0		; "2@" ( addr -- d )
	DC.W	max-theLink		; 32 bit fetch
TwoAt:	MOVE	(PS)+,D0
	MOVE.L	0(BP,D0.W),-(PS)
	RTS

	DC.B	2,'2!',0		; "2!" ( d addr -- )
	DC.W	twoat-theLink		; 32 bit store
TwoStore:
	MOVE	(PS)+,D0
	MOVE.L	(PS)+,0(BP,D0.W)
	RTS

	DC.B	9,'2CO'			; "2constant"
	DC.W	twostore-theLink	; defining: ( d -- )
TwoCon:	JSR	token-base(BP)		; executing: ( -- d )
	JSR	header-base(BP)
	JSR	dlit-base(BP)
	MOVE	#$4E75,(DP)+
	RTS

	DC.B	9,'2VA'			; "2variable"
	DC.W	twocon-theLink		; defining: ( -- )
TwoVar:	JSR	variable-base(BP)	; executing: ( -- addr )
	ADDQ.L	#2,DP
	RTS

	DC.B	64+3,'2>R'		; "2>r" ( d -- ) rstack: ( -- d )
	DC.W	twovar-theLink
TwoToR:	MOVE.L	(PS)+,-(RS)
	RTS

	DC.B	64+3,'2R>'		; "2r>" ( -- d ) rstack: ( d -- )
	DC.W	twotor-theLink
TwoRFrom:
	MOVE.L	(RS)+,-(PS)
	RTS
	
	DC.B	3,'A>R'			; "a>r" ( addr -- )
	DC.W	tworfrom-theLink	;   rstack: ( -- dabs.addr )
AToR:	JSR	toabs-base(BP)
	MOVE.L	(SP)+,A0
	MOVE.L	(PS)+,-(SP)
	JMP	(A0)

	DC.B	64+5,'2OV'		; "2over" ( d1 d2 -- d1 d2 d1 )
	DC.W	ator-theLink
TwoOver:
	MOVE.L	4(PS),-(PS)
	RTS

	DC.B	4,'2RO'			; "2rot" ( d1 d2 d3 -- d2 d3 d1 )
	DC.W	twoover-theLink
TwoRot:	MOVE.L	(PS)+,D0
	MOVE.L	(PS)+,D1
	MOVE.L	(PS),A0
	MOVE.L	D1,(PS)
	MOVE.L	D0,-(PS)
	MOVE.L	A0,-(PS)
	RTS

; floating point stack manipulation
	DC.B	64+5,'FDR'		; FDROP ( n1 n2 n3 n4 n5 -- )
	DC.W	tworot-theLink
fdrop:	ADDQ.L	#6,PS
	ADDQ.L	#4,PS
	RTS

	DC.B	4,'FDU'		; FDUP ( n5 n4 n3 n2 n1 -- n5 n4 n3 n2 n1  n5 n4 n3 n2 n1 )
	DC.W	fdrop-theLink
fdup:	LEA	10(PS),A0
	MOVE.L	-(A0),-(PS)
	MOVE.L	-(A0),-(PS)
	MOVE.W	-(A0),-(PS)
	RTS

	DC.B	5,'FSW'			; FSWAP ( f1 f2 -- f2 f1 )
	DC.W	fdup-theLink
fswap:	LEA	(PS),A0
	LEA	10(PS),A1
	MOVEQ	#4,D1
    @0:	MOVE	(A1),D0
	MOVE	(A0),(A1)+
	MOVE	D0,(A0)+
	DBRA	D1,@0
	RTS

	DC.B	5,'FPI'			; FPICK ( fn..f1 m|n³m³1 -- fn..f1 fm )
	DC.W	fswap-theLink
fpick:	MOVE	#$0A,-(PS)
	JSR	times-base(BP)
	MOVE	(PS)+,D0
	LEA	0(PS,D0.W),A0
	MOVE.L	-(A0),-(PS)
	MOVE.L	-(A0),-(PS)
	MOVE	-(A0),-(PS)
	RTS

	DC.B	5,'FPA'		; FPACK ( fn..f1 fnew m -- fn..f1 ) ( fm = fnew )
	DC.W	fpick-theLink
fpack:	MOVE	#$0A,-(PS)
	JSR	times-base(BP)
	MOVE	(PS)+,D0
	LEA	0(PS,D0.W),A0
	MOVE.L	(PS)+,(A0)+
	MOVE.L	(PS)+,(A0)+
	MOVE	(PS)+,(A0)+
	RTS

	DC.B	5,'FRO'		; FROLL ( fn..f1 m -- fn..fm+1 fm-1..f1 fm )
	DC.W	fpack-theLink
froll:	bsr.s	fpick
	LSR.W	#1,D0
	subq	#1,d0
    @0:	MOVE	-(A0),10(A0)
	DBRA	D0,@0
	JSR	fswap-base(BP)
	JMP	fdrop-base(BP)

; float - double number conversion
	DC.B	3,'D>F'			; D>F ( d -- n1 n2 n3 n4 n5 )
	DC.W	froll-theLink
dtof:	MOVE.L	(PS)+,(DP)
	MOVE.L	DP,-(RS)
	SUBQ.L	#6,PS
	SUBQ.L	#4,PS
	PEA	(PS)
	FL2X
	RTS

	DC.B	3,'F>D'			; F>D ( n1 n2 n3 n4 n5 -- d )
	DC.W	dtof-theLink
ftod:	PEA	(PS)
	MOVE.L	DP,-(RS)
	FX2L
	JSR	fdrop-base(BP)  
	MOVE.L	(DP),-(PS)
	RTS

	DC.B	2,'F@',0		; F@ ( addr -- n5 n4 n3 n2 n1 )
	DC.W	ftod-theLink
fat:	MOVE	(PS)+,D0
	LEA	10(BP,D0.W),A0
	MOVE.L	-(A0),-(PS)
	MOVE.L	-(A0),-(PS)
	MOVE	-(A0),-(PS)
	RTS

	DC.B	2,'F!',0		; F! ( n5 n4 n3 n2 n1 addr -- )
	DC.W	fat-theLink
fstore:	MOVE	(PS)+,D0
	LEA	0(BP,D0.W),A0
	MOVE.L	(PS)+,(A0)+
	MOVE.L	(PS)+,(A0)+
	MOVE	(PS)+,(A0)
	RTS

	DC.B	2,'F,',0		; F, ( n5 n4 n3 n2 n1 -- )
	DC.W	fstore-theLink
fcomma:	MOVE.L	(PS)+,(DP)+
	MOVE.L	(PS)+,(DP)+
	MOVE	(PS)+,(DP)+
	RTS

	DC.B	9,'FCO'		; FCONSTANT ( comp: f -- ) ( run: -- f )
	DC.W	fcomma-theLink
fcon:	JSR	create-base(BP)
	BSR.S	fcomma
	JSR	does-base(BP)
	BRA.S	fat

	DC.B	9,'FVA'		; FVARIABLE ( compile: -- ) ( run: -- addr )
	DC.W	fcon-theLink
fvar:	JSR	variable-base(BP)
	ADDQ.L #8,DP
	RTS

	DC.B	3,'SCI'			; SCI ( decimal.places -- )
	DC.W	fvar-theLink
sci:	CLR	-(PS)
  sci1:	MOVE.L	(PS)+,form-base(BP)
	RTS

	DC.B	3,'FIX'			; FIX ( decimal.places -- )
	DC.W	sci-theLink
fix:	MOVE	#$FFFF,-(PS)
	BRA.S	sci1

	DC.B	2,'F.',0		; F. ( n5 n4 n3 n2 n1 -- )
	DC.W	fix-theLink
fdot:	PEA	form-base(BP)
	PEA	(PS)
	PEA	$14(DP)
	FX2DEC
	JSR	fdrop-base(BP)
	PEA	form-base(BP)
	PEA	$14(DP)
	MOVE.L	A2,-(RS)
	FDEC2STR
  dwrd:	JSR	here-base(BP)
	JSR	count-base(BP)
	JSR	type-base(BP)
	JMP	space-base(BP)

	DC.B	8,'FCO'		; FCOMPARE ( f1 f2 -- f1 f2 [flag: -1|f1<f2 0|f1=f2 1|f1>f2] )
	DC.W	fdot-theLink
fcomp:	MOVE	#1,-(PS)
	PEA	2(PS)
	PEA	12(PS)
	FCMPX
	BGE.S	@0
	NEG	(PS)
	RTS
    @0:	BNE.S	@1
	CLR	(PS)
    @1:	RTS

	DC.B	2,'F+',0		; F+ ( f1 f2 -- f1+f2 )
	DC.W	fcomp-theLink
fplus:	PEA	(PS)
	PEA	10(PS)
	FADDX
  fd1:	JMP	fdrop-base(BP)

	DC.B	2,'F-',0		; F- ( f1 f2 -- f1-f2 )
	DC.W	fplus-theLink
fminus:	PEA	(PS)
	PEA	10(PS)
	FSUBX
	BRA.S	fd1

	DC.B	2,'F*',0		; F* ( f1 f2 -- f1*f2 )
	DC.W	fminus-theLink
fstar:	PEA	(PS)
	PEA	10(PS)
	FMULX
	BRA.S	fd1

	DC.B	2,'F/',0		; F/ ( f1 f2 -- f1/f2 )
	DC.W	fstar-theLink
fslash:	PEA	(PS)
	PEA	10(PS)
	FDIVX
	BRA.S	fd1

	DC.B	4,'FRE'			; FREM ( f1 f2 -- rem[f1/f2] )
	DC.W	fslash-theLink
frem:	PEA	(PS)
	PEA	10(PS)
	FREMX
	BRA.S	fd1

	DC.B	2,'F^',0		; F^ ( f1 f2 -- f1^f2 )
	DC.W	frem-theLink
ftothe:	PEA	(PS)
	PEA	10(PS)
	FXPWRY
	BRA.S	fd1

	DC.B	4,'FIN'			; FINT ( f -- int[f] )
	DC.W	ftothe-theLink
finte:	PEA	(PS)
	FTINTX
	RTS

	DC.B	4,'FAB'			; FABS ( f -- |f| )
	DC.W	finte -theLink
fabs:	PEA	(PS)
	FABSX
	RTS

	DC.B	5,'FSQ'			; FSQRT ( f -- sqrt[f] )
	DC.W	fabs-theLink
fsqrt:	PEA	(PS)
	FSQRTX
	RTS

	DC.B	4,'FSI'			; FSIN ( f -- sin[f] )
	DC.W	fsqrt-theLink
fsin:	PEA	(PS)
	FSINX
	RTS

	DC.B	4,'FCO'			; FCOS ( f -- cos[f] )
	DC.W	fsin-theLink
fcos:	PEA	(PS)
	FCOSX
	RTS

	DC.B	4,'FTA'			; FTAN ( f -- tan[f] )
	DC.W	fcos-theLink
ftan:	PEA	(PS)
	FTANX
	RTS

	DC.B	4,'FAT'			; FATN ( f -- atn[f] )
	DC.W	ftan-theLink
fatn:	PEA	(PS)
	FATNX
	RTS

	DC.B	4,'FEX'			; FEXP ( f1 -- e^f1 )
	DC.W	fatn-theLink
fexp:	PEA	(PS)
	FEXPX
	RTS

	DC.B	3,'FLN'			; FLN ( f1 -- ln[f1] )
	DC.W	fexp-theLink
fln:	PEA	(PS)
	FLNX
	RTS

	DC.B	4,'@PE'			; "@pen" ( -- h v )
	DC.W	fln-theLink
AtPen:	PEA	(DP)
	_GetPen
	MOVE.L	(DP),-(PS)
	RTS

	DC.B	64+4,'!PE'		; "!pen" ( h v -- )
	DC.W	atpen-theLink
SetPen:	MOVE.L	(PS)+,-(SP)
	_MoveTo
	RTS

	DC.B	64+3,'-TO'		; "-to" ( h v -- )
	DC.W	setpen-theLink
LineTo:	MOVE.L	(PS)+,-(SP)
	_LineTo
	RTS

	DC.B	64+5,'PMO'		; "pmode" ( mode -- )
	DC.W	lineto-theLink
PMode:	MOVE	(PS)+,-(SP)
	_PenMode
	RTS

	DC.B	6,'@MO'			; "@mouse" ( -- h v )
	DC.W	pmode-theLink
AtMouse:
	SUBQ.L	#4,PS
	PEA	(PS)
	_GetMouse
	RTS

	DC.B	4,'TAS'			; "task" ( -- ) a no-op word
	DC.W	atmouse-theLink		;  use:  forget task : task ;
Task:	RTS				;  to cleanup dictionary
DictEnd: